The 640 MEG Shareware Studio 2/The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO/pascal/tpb4_src.zip/DEARC.PAS

Pascal/Delphi Source File | 1988-09-13 | 23KB | 964 lines

{ TPBoard 4.2 Copyright (c) 1987,88 by Jon Schneider & Rick Petersen
  Portions Copyright (c) 1986,87 by Steve Fox and Les Archambault

  Last modified  ::  7-12-88 4:43 pm
}

{$R-}                             {Range checking off}
{$B-}                             {Boolean complete evaluation off}
{$S-}                             {Stack checking off}
{$I+}                             {I/O checking on}
{$N-}                             {No numeric coprocessor}

Unit DeArc;

Interface

Uses
  TPCrt, Dos, Globals, Core1, Core2, TPSTRING;


procedure TypeArc(var arcname, TypeName : DosFileName);


  {==========================================================================}


Implementation


  procedure TypeArc(var arcname, TypeName : DosFileName);

  const
    {.F-}
   blocksize   = $4000;       { size of file buffers in heap }
   arcmarc     = 26;          { special archive marker }
   arcver      = 9;           { max archive header version code }
   strlen      = 100;         { standard string length }
   DLE         = $90;
   error       = -1;
   speof       = 256;
   numvals     = 256;         { 1 less than the number of values }
   tabsize     = 4096;
   tabsizem1   = 4095;
   no_pred     = -1;
   empty       = -1;
   crunch_bits = 12;
   squash_bits = 13;
   init_bits   = 9;
   first       = 257;
   clear       = 256;
   hsizem1     = 8191;
   bitsm1      = 27;

   rmask : array[0..8] of Byte
         = ($00, $01, $03, $07, $0f, $1f, $3f, $7f, $ff);

type
   strtype     = string[strlen];

   entry       = record
                    used : Boolean;
                    next : Integer;
                    predecessor : Integer;
                    follower : Byte;
                  end;

   nd          = record
                    child : array[0..1] of Integer;
                 end;

   buftype     = array[1..blocksize] of Byte;
   prefixtype  = array[0..hsizem1] of Integer;
   suffixtype  = array[0..hsizem1] of Byte;
   stack1type  = array[0..hsizem1] of Byte;
   stacktype   = array[0..tabsizem1] of Byte;
   strtabtype  = array[0..tabsizem1] of entry;


   bufptr      = ^buftype;
   prefixptr   = ^prefixtype;
   suffixptr   = ^suffixtype;
   stack1ptr   = ^stack1type;
   stackptr    = ^stacktype;
   strtabptr   = ^strtabtype;

var
   strtab_hold                : entry;
   arcfile                    : file;
   arcbuf                     : bufptr;
   prefixbuf                  : prefixptr;
   suffixbuf                  : suffixptr;
   stack1buf                  : stack1ptr;
   stackbuf                   : stackptr;
   strtabbuf                  : strtabptr;
   arcptr,
   arccount                   : word;
   extname                    : DosFileName;
   state                      : (nohist, inrep);
   size                       : longint;
   node                       : array[0..numvals] of nd;
   lastc, bpos, curin,
   numnodes, sp,
   code_count,
   maxcode, oldcode,
   finchar, clear_flg,
   free_ent, maxcodemax,
   offset, line_count,
   bits, n_bits,
   inbuf                      : Integer;
   firstch, OK, firstc,
   newhash, endfile           : Boolean;
   buf                        : array[0..bitsm1] of Byte;

   {.F+}


    function Fn_To_Str(var fn : fntype) : strtype;

    var
      s               : strtype;
      i               : Integer;

    begin
      s := '';
      i := 0;
      while fn[i] <> #0 do
        begin
          s := s+fn[i];
          Inc(i);
        end;
      if Pos('.', s) = 0 then
        s := s+'.';
      Fn_To_Str := s;
    end;


    procedure Read_Arc_Block;

    begin
      if EoF(arcfile) then
        endfile := True
      else
        BlockRead(arcfile, arcbuf^, blocksize, arccount);
      arcptr := 1;
    end;


    procedure Open_Arc;

    begin
      Assign(arcfile, arcname);
      Reset(arcfile, 1);
      endfile := False;
      Read_Arc_Block;             { pre-load buffer }
    end;


    function Get_Arc : Byte;

    begin
      if endfile then
        Get_Arc := 0
      else
        begin
          Get_Arc := arcbuf^[arcptr];
          if arcptr = arccount then
            Read_Arc_Block
          else
            Inc(arcptr)
        end;
    end;


    procedure Put_Ext(c : Byte);

    var
      i               : Integer;

    begin
      if OK then
        begin
          if c = Integer(TAB) then
            for i := 1 to (8-(WhereX mod 8)) do
              Write(Com, ' ')
          else if (not(c in [3..7, 11, 14..31])) then
            Write(Com, Chr(c));
          if (user_rec.lines <> 99) and (Chr(c) = LF) then
            begin
              Inc(line_count);
              if line_count mod user_rec.lines = 0 then
                pause;
              if brk or ((line_count > line_abort) and
                (line_abort > 0) and (user_rec.access < 255)) then
                OK := False;
            end;
        end;
    end;


    procedure Close_Arc;

    begin
      {$I-}
      Close(arcfile);
      {$I+}
    end;


    procedure FSkip(offset : LongInt);

    var
      rec             : LongInt;

    begin
      if (offset+arcptr) <= arccount then
        arcptr := arcptr+offset
      else
        begin
          rec := FilePos(arcfile)+(offset-(arccount-arcptr)-1);
          {$I-}
          Seek(arcfile, rec);
          {$I+}
          OK := (IoResult = 0);
          if OK then
            Read_Arc_Block;
        end;
    end;


    procedure FRead(var buf; reclen : Integer);

    var
      i               : Integer;
      b               : array[1..28] of Byte absolute buf;

    begin
      for i := 1 to reclen do
        b[i] := Get_Arc;
    end;


    function Read_Hdr(var hdr : heads) : Boolean;

    begin
      if OK then
        begin
          if endfile then
            begin
              Read_Hdr := False;  { end of file }
              Exit;
            end;
          if Get_Arc <> arcmarc then
            begin
              WriteLn(Com, 'Missing or invalid header in ', arcname);
              OK := False;
              Exit;
            end;
          hdrver := Get_Arc;
          if hdrver < 0 then
            begin
              WriteLn(Com, 'Missing or invalid header in '+arcname);
              OK := False;
              Exit;
            end;
          if hdrver = 0 then
            begin
              Read_Hdr := False;  { end of file }
              Exit;
            end;
          if hdrver = 1 then
            begin
              FRead(hdr, SizeOf(heads)-SizeOf(LongInt));
              hdrver := 2;
              hdr.Length := hdr.size;
            end
          else
            FRead(hdr, SizeOf(heads));
          Read_Hdr := True;
        end;
    end;


    procedure Putc_Ncr(c : Integer);

    begin
      case state of
        nohist : if c = DLE then
                   state := inrep
                 else
                   begin
                     lastc := c;
                     Put_Ext(c);
                   end;
        inrep :
          begin
            if c = 0 then
              Put_Ext(DLE)
            else
              begin
                Dec(c);
                while (c <> 0) and OK do
                  begin
                    Put_Ext(lastc);
                    Dec(c);
                  end;
              end;
            state := nohist
          end;
      end;
    end;


    function Getc_Unp : Integer;

    begin
      if size = 0.0 then
        Getc_Unp := -1
      else
        begin
          Dec(size);
          Getc_Unp := Get_Arc;
        end;
    end;


    procedure Init_Usq;

    var
      i               : Integer;

    begin
      bpos := 99;
      FRead(numnodes, SizeOf(numnodes));
      if (numnodes < 0) or (numnodes > numvals) then
        begin
          WriteLn(Com, extname, ' has an invalid decode tree');
          OK := False;
        end
      else
        begin
          node[0].child[0] := -(speof+1);
          node[0].child[1] := -(speof+1);
          for i := 0 to numnodes-1 do
            begin
              FRead(node[i].child[0], SizeOf(Integer));
              FRead(node[i].child[1], SizeOf(Integer));
            end;
        end;
    end;


    function Getc_Usq : Integer;

    var
      i               : Integer;

    begin
      i := 0;
      while (i >= 0) and OK do
        begin
          Inc(bpos);
          if bpos > 7 then
            begin
              curin := Getc_Unp;
              if curin = error then
                begin
                  Getc_Usq := error;
                  Exit;
                end;
              bpos := 0;
              i := node[i].child[1 and curin];
            end
          else
            begin
              curin := curin shr 1;
              i := node[i].child[1 and curin];
            end;
        end;
      i := -(i+1);
      if i = speof then
        Getc_Usq := -1
      else
        Getc_Usq := i;
    end;


    function H(Pred, foll : Integer) : Integer;

    var
      Local           : Real;
      s               : string[20];
      i, V            : Integer;
      c               : Char;

    begin
      if not newhash then
        begin
          Local := (Pred+foll) or $0800;
          if Local < 0.0 then
            Local := Local+65536.0;
          Local := (Local*Local)/64.0;
          Str(Local:15:5, s);
          V := 0;
          i := 1;
          c := s[1];
          while (c <> '.') and OK do
            begin
              if (c >= '0') and (c <= '9') then
                V := V*10+(Ord(c)-Ord('0'));
              Inc(i);
              c := s[i];
            end;
          H := V and $0FFF;
        end
      else
        begin
          Local := (Pred+foll)*15073;
          Str(Local:15:5, s);
          V := 0;
          i := 1;
          c := s[1];
          while (c <> '.') and OK do
            begin
              if (c >= '0') and (c <= '9') then
                V := V*10+(Ord(c)-Ord('0'));
              Inc(i);
              c := s[i];
            end;
          H := V and $0FFF;
        end;
    end;


    function Eolist(index : Integer) : Integer;

    var
      temp            : Integer;

    begin
      temp := strtabbuf^[index].next;
      while (temp <> 0) and OK do
        begin
          index := temp;
          temp := strtabbuf^[index].next;
        end;
      Eolist := index;
    end;


    function Hash(Pred, foll : Integer) : Integer;

    var
      Local           : Integer;
      tempnext        : Integer;

    begin
      Local := H(Pred, foll);
      if not strtabbuf^[local].used then
        Hash := Local
      else
        begin
          Local := Eolist(Local);
          tempnext := (Local+101) and $0FFF;
          while (strtabbuf^[tempnext].used) and OK do
            begin
              Inc(tempnext);
              if tempnext = tabsize then
                tempnext := 0;
            end;
          strtabbuf^[local].next := tempnext;
          Hash := tempnext;
        end;
    end;


    procedure Upd_Tab(Pred, foll : Integer);

    begin
      with strtabbuf^[Hash(Pred, foll)] do
        begin
          used := True;
          next := 0;
          predecessor := Pred;
          follower := foll;
        end;
    end;


    function Gocode : Integer;

    var
      localbuf        : Integer;
      returnval       : Integer;

    begin
      if inbuf = empty then
        begin
          localbuf := Getc_Unp;
          if localbuf = -1 then
            begin
              Gocode := -1;
              Exit;
            end;
          localbuf := localbuf and $00FF;
          inbuf := Getc_Unp;
          if inbuf = -1 then
            begin
              Gocode := -1;
              Exit;
            end;
          inbuf := inbuf and $00FF;
          returnval := ((localbuf shl 4) and $0FF0)+((inbuf shr 4) and $000F);
          inbuf := inbuf and $000F;
        end
      else
        begin
          localbuf := Getc_Unp;
          if localbuf = -1 then
            begin
              Gocode := -1;
              Exit;
            end;
          localbuf := localbuf and $00FF;
          returnval := localbuf+((inbuf shl 8) and $0F00);
          inbuf := empty;
        end;
      Gocode := returnval;
    end;


    procedure Push(c : Integer);

    begin
      stackbuf^[sp] := c;
      Inc(sp);
      if sp >= tabsize then
        begin
          WriteLn(Com, 'Stack overflow');
          OK := False;
        end;
    end;


    function Pop    : Integer;

    begin
      if sp > 0 then
        begin
          Dec(sp);
          Pop := stackbuf^[sp];
        end
      else
        Pop := empty;
    end;


    procedure Init_Tab;

    var
      i               : Integer;

    begin
      FillChar(strtab_hold, SizeOf(strtab_hold), 0);
      for i := 0 to tabsizem1 do
        strtabbuf^[i] := strtab_hold;
      for i := 0 to 255 do
        Upd_Tab(no_pred, i);
      inbuf := empty;
      { outbuf := EMPTY }
    end;


    procedure Init_Ucr(i : Integer);

    begin
      newhash := (i = 1);
      sp := 0;
      Init_Tab;
      code_count := tabsize-256;
      firstc := True;
    end;


    function Getc_Ucr : Integer;

    var
      code            : Integer;
      newcode         : Integer;

    begin
      if firstc then
        begin
          firstc := False;
          oldcode := Gocode;
          finchar := strtabbuf^[oldcode].follower;
          Getc_Ucr := finchar;
          Exit;
        end;
      if sp = 0 then
        begin
          newcode := Gocode;
          code := newcode;
          if code = -1 then
            begin
              Getc_Ucr := -1;
              Exit;
            end;
          if not strtabbuf^[code].used then
            begin
              code := oldcode;
              Push(finchar);
            end;
          while (strtabbuf^[code].predecessor <> no_pred) and OK do
            with strtabbuf^[code] do
              begin
                Push(follower);
                code := predecessor;
              end;
          finchar := strtabbuf^[code].follower;
          Push(finchar);
          if code_count <> 0 then
            begin
              Upd_Tab(oldcode, finchar);
              Dec(code_count);
            end;
          oldcode := newcode;
        end;
      Getc_Ucr := Pop;
    end;


    function Getcode : Integer;

    var
      code, r_off,
      bitsx           : Integer;
      bp              : Byte;

    begin
      if firstch then
        begin
          offset := 0;
          sizex := 0;
          firstch := False;
        end;
      bp := 0;
      if (clear_flg > 0) or (offset >= sizex) or (free_ent > maxcode) then
        begin
          if free_ent > maxcode then
            begin
              Inc(n_bits);
              if n_bits = bits then
                maxcode := maxcodemax
              else
                maxcode := (1 shl n_bits)-1;
            end;
          if clear_flg > 0 then
            begin
              n_bits := init_bits;
              maxcode := (1 shl n_bits)-1;
              clear_flg := 0;
            end;

          sizex := 0;
          code := 0;
          while (sizex < n_bits) and (code <> -1) do
            begin
              code := Getc_Unp;
              if code <> -1 then
                begin
                  buf[sizex] := code;
                  Inc(sizex)
                end;
            end;

          if sizex <= 0 then
            begin
              Getcode := -1;
              Exit;
            end;
          offset := 0;
          sizex := (sizex shl 3)-(n_bits-1);
        end;
      r_off := offset;
      bitsx := n_bits;
      { get first byte }
      bp := bp+(r_off shr 3);
      r_off := r_off and 7;

      { get first parft (low order bits) }
      code := buf[bp] shr r_off;
      Inc(bp);
      bitsx := bitsx-(8-r_off);
      r_off := 8-r_off;

      if bitsx >= 8 then
        begin
          code := code or (buf[bp] shl r_off);
          Inc(bp);
          r_off := r_off+8;
          bitsx := bitsx-8;
        end;
      code := code or ((buf[bp] and rmask[bitsx]) shl r_off);
      offset := offset+n_bits;
      Getcode := code;
    end;


    procedure Decomp(squashflag : Integer);

    var
      stackp,
      finchar         : Integer;
      code,
      oldcode,
      incode          : Integer;

    begin
      if squashflag = 0 then
        bits := crunch_bits
      else
        bits := squash_bits;

      if firstch then
        maxcodemax := 1 shl bits;

      if squashflag = 0 then
        begin
          code := Getc_Unp;
          if code <> bits then
            begin
              WriteLn(Com, extname, ' packed with ', code, ' bits, I can only handle ', bits);
              Exit;
            end;
        end;
      clear_flg := 0;
      n_bits := init_bits;
      maxcode := (1 shl n_bits)-1;
      for code := 255 downto 0 do
        begin
          prefixbuf^[code] := 0;
          suffixbuf^[code] := code;
        end;

      free_ent := first;
      oldcode := Getcode;
      finchar := oldcode;
      if oldcode = -1 then
        Exit;
      if squashflag = 0 then
        Putc_Ncr(finchar)
      else
        Put_Ext(finchar);
      stackp := 0;

      code := Getcode;
      while (code > -1) and OK do
        begin
          if code = clear then
            begin
              for code := 255 downto 0 do
                prefixbuf^[code] := 0;
              clear_flg := 1;
              free_ent := first-1;
              code := Getcode;
            end;
          incode := code;
          if code >= free_ent then
            begin
              stack1buf^[stackp] := finchar;
              Inc(stackp);
              code := oldcode;
            end;
          while (code >= 256) and OK do
            begin
              stack1buf^[stackp] := suffixbuf^[code];
              Inc(stackp);
              code := prefixbuf^[code];
            end;
          finchar := suffixbuf^[code];
          stack1buf^[stackp] := finchar;
          Inc(stackp);
          repeat
            Dec(stackp);
            if squashflag = 0 then
              Putc_Ncr(stack1buf^[stackp])
            else
              Put_Ext(stack1buf^[stackp]);
          until (stackp <= 0) or (not OK);
          code := free_ent;
          if code < maxcodemax then
            begin
              prefixbuf^[code] := oldcode;
              suffixbuf^[code] := finchar;
              free_ent := code+1;
            end;
          oldcode := incode;
          code := Getcode;
        end;
    end;


    procedure Unpack(var hdr : heads);

    var
      c               : Integer;

    begin
      size := hdr.size;
      state := nohist;
      firstch := True;
      case hdrver of
        1, 2 :
          begin
            c := Getc_Unp;
            while (c <> -1) and OK do
              begin
                Put_Ext(c);
                c := Getc_Unp;
              end;
          end;
        3 :
          begin
            c := Getc_Unp;
            while (c <> -1) and OK do
              begin
                Putc_Ncr(c);
                c := Getc_Unp;
              end;
          end;
        4 :
          begin
            Init_Usq;
            c := Getc_Usq;
            while (c <> -1) and OK do
              begin
                Putc_Ncr(c);
                c := Getc_Usq;
              end;
          end;
        5 :
          begin
            Init_Ucr(0);
            c := Getc_Ucr;
            while (c <> -1) and OK do
              begin
                Put_Ext(c);
                c := Getc_Ucr;
              end;
          end;
        6 :
          begin
            Init_Ucr(0);
            c := Getc_Ucr;
            while (c <> -1) and OK do
              begin
                Putc_Ncr(c);
                c := Getc_Ucr;
              end;
          end;
        7 :
          begin
            Init_Ucr(1);
            c := Getc_Ucr;
            while (c <> -1) and OK do
              begin
                Putc_Ncr(c);
                c := Getc_Ucr;
              end;
          end;
        8 :
          begin
            Decomp(0);
          end;
        9 :
          begin
            Decomp(1);
          end;
      end;
    end;


    procedure Extract_File(var hdr : heads);

    begin
      if TypeName = extname then
        Unpack(hdr)
      else
        FSkip(hdr.size);
    end;


    function Verify_File(var hdr : heads) : Boolean;

    begin
      Verify_File := True;        { default case }
      extname := Fn_To_Str(hdr.name);
      extname := StUpcase(extname);
      if hdrver > arcver then
        begin
          WriteLn(Com, 'Skipping: '+extname+' -- New version.');
          Verify_File := False;
        end;
    end;


    procedure init;

    begin
      OK := True;
      WriteLn(Com);
      New(strtabbuf);
      New(arcbuf);
      New(prefixbuf);
      New(suffixbuf);
      New(stack1buf);
      New(stackbuf);
      line_count := 0
    end;


    procedure Extract_Arc;

    var
      hdr             : heads;

    begin
      Open_Arc;
      while (Read_Hdr(hdr)) and OK do
        if Verify_File(hdr) then
          Extract_File(hdr)
        else
          FSkip(hdr.size);
      Close_Arc;
    end;


    procedure deinit;

    begin
      Dispose(stackbuf);
      Dispose(stack1buf);
      Dispose(suffixbuf);
      Dispose(prefixbuf);
      Dispose(arcbuf);
      Dispose(strtabbuf);
    end;


  begin
    init;
    Extract_Arc;
    if brk or ((line_count > line_abort) and (line_abort > 0) and
      (user_rec.access < 255)) then
      begin
        WriteLn(Com);
        WriteLn(Com, 'Sorry, you can only ''Type'' ', line_abort, ' lines.');
      end;
    deinit;
  end;

end.                              { of DEARC.PAS }